home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / ice-9 / pretty-print.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  11.5 KB  |  321 lines
  1. ;;;; -*-scheme-*-
  2. ;;;;
  3. ;;;;     Copyright (C) 2001 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;;
  20. ;;;; As a special exception, the Free Software Foundation gives permission
  21. ;;;; for additional uses of the text contained in its release of GUILE.
  22. ;;;;
  23. ;;;; The exception is that, if you link the GUILE library with other files
  24. ;;;; to produce an executable, this does not by itself cause the
  25. ;;;; resulting executable to be covered by the GNU General Public License.
  26. ;;;; Your use of that executable is in no way restricted on account of
  27. ;;;; linking the GUILE library code into it.
  28. ;;;;
  29. ;;;; This exception does not however invalidate any other reasons why
  30. ;;;; the executable file might be covered by the GNU General Public License.
  31. ;;;;
  32. ;;;; This exception applies only to the code released by the
  33. ;;;; Free Software Foundation under the name GUILE.  If you copy
  34. ;;;; code from other Free Software Foundation releases into a copy of
  35. ;;;; GUILE, as the General Public License permits, the exception does
  36. ;;;; not apply to the code that you add in this way.  To avoid misleading
  37. ;;;; anyone as to the status of such modified files, you must delete
  38. ;;;; this exception notice from them.
  39. ;;;;
  40. ;;;; If you write modifications of your own for GUILE, it is your choice
  41. ;;;; whether to permit this exception to apply to your modifications.
  42. ;;;; If you do not wish that, delete this exception notice.
  43. ;;;; 
  44. (define-module (ice-9 pretty-print)
  45.   :export (pretty-print))
  46.  
  47. ;; From SLIB.
  48.  
  49. ;;"genwrite.scm" generic write used by pretty-print and truncated-print.
  50. ;; Copyright (c) 1991, Marc Feeley
  51. ;; Author: Marc Feeley (feeley@iro.umontreal.ca)
  52. ;; Distribution restrictions: none
  53.  
  54. (define genwrite:newline-str (make-string 1 #\newline))
  55.  
  56. (define (generic-write obj display? width output)
  57.  
  58.   (define (read-macro? l)
  59.     (define (length1? l) (and (pair? l) (null? (cdr l))))
  60.     (let ((head (car l)) (tail (cdr l)))
  61.       (case head
  62.         ((quote quasiquote unquote unquote-splicing) (length1? tail))
  63.         (else                                        #f))))
  64.  
  65.   (define (read-macro-body l)
  66.     (cadr l))
  67.  
  68.   (define (read-macro-prefix l)
  69.     (let ((head (car l)) (tail (cdr l)))
  70.       (case head
  71.         ((quote)            "'")
  72.         ((quasiquote)       "`")
  73.         ((unquote)          ",")
  74.         ((unquote-splicing) ",@"))))
  75.  
  76.   (define (out str col)
  77.     (and col (output str) (+ col (string-length str))))
  78.  
  79.   (define (wr obj col)
  80.  
  81.     (define (wr-expr expr col)
  82.       (if (read-macro? expr)
  83.         (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
  84.         (wr-lst expr col)))
  85.  
  86.     (define (wr-lst l col)
  87.       (if (pair? l)
  88.       (let loop ((l (cdr l))
  89.              (col (and col (wr (car l) (out "(" col)))))
  90.         (cond ((not col) col)
  91.           ((pair? l)
  92.            (loop (cdr l) (wr (car l) (out " " col))))
  93.           ((null? l) (out ")" col))
  94.           (else      (out ")" (wr l (out " . " col))))))
  95.       (out "()" col)))
  96.  
  97.     (cond ((pair? obj)        (wr-expr obj col))
  98.           ((null? obj)        (wr-lst obj col))
  99.           ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
  100.           ((boolean? obj)     (out (if obj "#t" "#f") col))
  101.           ((number? obj)      (out (number->string obj) col))
  102.           ((symbol? obj)      (out (symbol->string obj) col))
  103.           ((procedure? obj)   (out "#[procedure]" col))
  104.           ((string? obj)      (if display?
  105.                                 (out obj col)
  106.                                 (let loop ((i 0) (j 0) (col (out "\"" col)))
  107.                                   (if (and col (< j (string-length obj)))
  108.                                     (let ((c (string-ref obj j)))
  109.                                       (if (or (char=? c #\\)
  110.                                               (char=? c #\"))
  111.                                         (loop j
  112.                                               (+ j 1)
  113.                                               (out "\\"
  114.                                                    (out (substring obj i j)
  115.                                                         col)))
  116.                                         (loop i (+ j 1) col)))
  117.                                     (out "\""
  118.                                          (out (substring obj i j) col))))))
  119.           ((char? obj)        (if display?
  120.                                 (out (make-string 1 obj) col)
  121.                                 (out (case obj
  122.                                        ((#\space)   "space")
  123.                                        ((#\newline) "newline")
  124.                                        (else        (make-string 1 obj)))
  125.                                      (out "#\\" col))))
  126.       (else               (out (object->string obj) col))))
  127.  
  128.   (define (pp obj col)
  129.  
  130.     (define (spaces n col)
  131.       (if (> n 0)
  132.         (if (> n 7)
  133.           (spaces (- n 8) (out "        " col))
  134.           (out (substring "        " 0 n) col))
  135.         col))
  136.  
  137.     (define (indent to col)
  138.       (and col
  139.            (if (< to col)
  140.              (and (out genwrite:newline-str col) (spaces to 0))
  141.              (spaces (- to col) col))))
  142.  
  143.     (define (pr obj col extra pp-pair)
  144.       (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
  145.         (let ((result '())
  146.               (left (min (+ (- (- width col) extra) 1) max-expr-width)))
  147.           (generic-write obj display? #f
  148.             (lambda (str)
  149.               (set! result (cons str result))
  150.               (set! left (- left (string-length str)))
  151.               (> left 0)))
  152.           (if (> left 0) ; all can be printed on one line
  153.             (out (reverse-string-append result) col)
  154.             (if (pair? obj)
  155.               (pp-pair obj col extra)
  156.               (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
  157.         (wr obj col)))
  158.  
  159.     (define (pp-expr expr col extra)
  160.       (if (read-macro? expr)
  161.         (pr (read-macro-body expr)
  162.             (out (read-macro-prefix expr) col)
  163.             extra
  164.             pp-expr)
  165.         (let ((head (car expr)))
  166.           (if (symbol? head)
  167.             (let ((proc (style head)))
  168.               (if proc
  169.                 (proc expr col extra)
  170.                 (if (> (string-length (symbol->string head))
  171.                        max-call-head-width)
  172.                   (pp-general expr col extra #f #f #f pp-expr)
  173.                   (pp-call expr col extra pp-expr))))
  174.             (pp-list expr col extra pp-expr)))))
  175.  
  176.     ; (head item1
  177.     ;       item2
  178.     ;       item3)
  179.     (define (pp-call expr col extra pp-item)
  180.       (let ((col* (wr (car expr) (out "(" col))))
  181.         (and col
  182.              (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
  183.  
  184.     ; (item1
  185.     ;  item2
  186.     ;  item3)
  187.     (define (pp-list l col extra pp-item)
  188.       (let ((col (out "(" col)))
  189.         (pp-down l col col extra pp-item)))
  190.  
  191.     (define (pp-down l col1 col2 extra pp-item)
  192.       (let loop ((l l) (col col1))
  193.         (and col
  194.              (cond ((pair? l)
  195.                     (let ((rest (cdr l)))
  196.                       (let ((extra (if (null? rest) (+ extra 1) 0)))
  197.                         (loop rest
  198.                               (pr (car l) (indent col2 col) extra pp-item)))))
  199.                    ((null? l)
  200.                     (out ")" col))
  201.                    (else
  202.                     (out ")"
  203.                          (pr l
  204.                              (indent col2 (out "." (indent col2 col)))
  205.                              (+ extra 1)
  206.                              pp-item)))))))
  207.  
  208.     (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
  209.  
  210.       (define (tail1 rest col1 col2 col3)
  211.         (if (and pp-1 (pair? rest))
  212.           (let* ((val1 (car rest))
  213.                  (rest (cdr rest))
  214.                  (extra (if (null? rest) (+ extra 1) 0)))
  215.             (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
  216.           (tail2 rest col1 col2 col3)))
  217.  
  218.       (define (tail2 rest col1 col2 col3)
  219.         (if (and pp-2 (pair? rest))
  220.           (let* ((val1 (car rest))
  221.                  (rest (cdr rest))
  222.                  (extra (if (null? rest) (+ extra 1) 0)))
  223.             (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
  224.           (tail3 rest col1 col2)))
  225.  
  226.       (define (tail3 rest col1 col2)
  227.         (pp-down rest col2 col1 extra pp-3))
  228.  
  229.       (let* ((head (car expr))
  230.              (rest (cdr expr))
  231.              (col* (wr head (out "(" col))))
  232.         (if (and named? (pair? rest))
  233.           (let* ((name (car rest))
  234.                  (rest (cdr rest))
  235.                  (col** (wr name (out " " col*))))
  236.             (tail1 rest (+ col indent-general) col** (+ col** 1)))
  237.           (tail1 rest (+ col indent-general) col* (+ col* 1)))))
  238.  
  239.     (define (pp-expr-list l col extra)
  240.       (pp-list l col extra pp-expr))
  241.  
  242.     (define (pp-LAMBDA expr col extra)
  243.       (pp-general expr col extra #f pp-expr-list #f pp-expr))
  244.  
  245.     (define (pp-IF expr col extra)
  246.       (pp-general expr col extra #f pp-expr #f pp-expr))
  247.  
  248.     (define (pp-COND expr col extra)
  249.       (pp-call expr col extra pp-expr-list))
  250.  
  251.     (define (pp-CASE expr col extra)
  252.       (pp-general expr col extra #f pp-expr #f pp-expr-list))
  253.  
  254.     (define (pp-AND expr col extra)
  255.       (pp-call expr col extra pp-expr))
  256.  
  257.     (define (pp-LET expr col extra)
  258.       (let* ((rest (cdr expr))
  259.              (named? (and (pair? rest) (symbol? (car rest)))))
  260.         (pp-general expr col extra named? pp-expr-list #f pp-expr)))
  261.  
  262.     (define (pp-BEGIN expr col extra)
  263.       (pp-general expr col extra #f #f #f pp-expr))
  264.  
  265.     (define (pp-DO expr col extra)
  266.       (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
  267.  
  268.     ; define formatting style (change these to suit your style)
  269.  
  270.     (define indent-general 2)
  271.  
  272.     (define max-call-head-width 5)
  273.  
  274.     (define max-expr-width 50)
  275.  
  276.     (define (style head)
  277.       (case head
  278.         ((lambda let* letrec define) pp-LAMBDA)
  279.         ((if set!)                   pp-IF)
  280.         ((cond)                      pp-COND)
  281.         ((case)                      pp-CASE)
  282.         ((and or)                    pp-AND)
  283.         ((let)                       pp-LET)
  284.         ((begin)                     pp-BEGIN)
  285.         ((do)                        pp-DO)
  286.         (else                        #f)))
  287.  
  288.     (pr obj col 0 pp-expr))
  289.  
  290.   (if width
  291.     (out genwrite:newline-str (pp obj 0))
  292.     (wr obj 0))
  293.   ;; Return `unspecified'
  294.   (if #f #f))
  295.  
  296. ; (reverse-string-append l) = (apply string-append (reverse l))
  297.  
  298. (define (reverse-string-append l)
  299.  
  300.   (define (rev-string-append l i)
  301.     (if (pair? l)
  302.       (let* ((str (car l))
  303.              (len (string-length str))
  304.              (result (rev-string-append (cdr l) (+ i len))))
  305.         (let loop ((j 0) (k (- (- (string-length result) i) len)))
  306.           (if (< j len)
  307.             (begin
  308.               (string-set! result k (string-ref str j))
  309.               (loop (+ j 1) (+ k 1)))
  310.             result)))
  311.       (make-string i)))
  312.  
  313.   (rev-string-append l 0))
  314.  
  315. ;"pp.scm" Pretty-Print
  316. (define (pretty-print obj . opt)
  317.   (let ((port (if (pair? opt) (car opt) (current-output-port))))
  318.     (generic-write obj #f 79
  319.            (lambda (s) (display s port) #t))))
  320.  
  321.